home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / TUT03NEW.ZIP / TUT3.PAS < prev    next >
Pascal/Delphi Source File  |  1994-12-07  |  9KB  |  287 lines
  1. (*****************************************************************************)
  2. (*                                                                           *)
  3. (* TUT3.PAS - VGA Trainer Program 3 (in Pascal)                              *)
  4. (*                                                                           *)
  5. (* "The VGA Trainer Program" is written by Denthor of Asphyxia.  However it  *)
  6. (* was limited to Pascal only in its first run.  All I have done is taken    *)
  7. (* his original release, translated it to C++, and touched up a few things.  *)
  8. (* I take absolutely no credit for the concepts presented in this code, and  *)
  9. (* am NOT the person to ask for help if you are having trouble.              *)
  10. (*                                                                           *)
  11. (* Program Notes : This program presents many new concepts, including:       *)
  12. (*                 Cirle and Line algorithms.                                *)
  13. (*                                                                           *)
  14. (* Author        : Grant Smith (Denthor)  - denthor@beastie.cs.und.ac.za     *)
  15. (*                                                                           *)
  16. (*****************************************************************************)
  17.  
  18. {$X+}
  19. USES crt;
  20.  
  21. CONST VGA = $a000;
  22.  
  23. VAR loop1:integer;
  24.     Pall : Array [1..199,1..3] of byte;
  25.       { This is our temporary pallette. We ony use colors 1 to 199, so we
  26.         only have variables for those ones. }
  27.  
  28. {──────────────────────────────────────────────────────────────────────────}
  29. Procedure SetMCGA;  { This procedure gets you into 320x200x256 mode. }
  30. BEGIN
  31.   asm
  32.      mov        ax,0013h
  33.      int        10h
  34.   end;
  35. END;
  36.  
  37.  
  38. {──────────────────────────────────────────────────────────────────────────}
  39. Procedure SetText;  { This procedure returns you to text mode.  }
  40. BEGIN
  41.   asm
  42.      mov        ax,0003h
  43.      int        10h
  44.   end;
  45. END;
  46.  
  47.  
  48. {──────────────────────────────────────────────────────────────────────────}
  49. Procedure Putpixel (X,Y : Integer; Col : Byte);
  50.   { This puts a pixel on the screen by writing directly to memory. }
  51. BEGIN
  52.   Mem [VGA:X+(Y*320)]:=Col;
  53. END;
  54.  
  55.  
  56. {──────────────────────────────────────────────────────────────────────────}
  57. procedure WaitRetrace; assembler;
  58. label
  59.   l1, l2;
  60. asm
  61.     mov dx,3DAh
  62. l1:
  63.     in al,dx
  64.     and al,08h
  65.     jnz l1
  66. l2:
  67.     in al,dx
  68.     and al,08h
  69.     jz  l2
  70. end;
  71.  
  72.  
  73. {──────────────────────────────────────────────────────────────────────────}
  74. Procedure Pal(ColorNo : Byte; R,G,B : Byte);
  75.   { This sets the Red, Green and Blue values of a certain color }
  76. Begin
  77.    Port[$3c8] := ColorNo;
  78.    Port[$3c9] := R;
  79.    Port[$3c9] := G;
  80.    Port[$3c9] := B;
  81. End;
  82.  
  83.  
  84. {──────────────────────────────────────────────────────────────────────────}
  85. Procedure Circle (X,Y,rad:integer;Col:Byte);
  86.   { This draws a circle with centre X,Y, with Rad as it's radius }
  87. VAR deg:real;
  88. BEGIN
  89.   deg:=0;
  90.   repeat
  91.     X:=round(rad*COS (deg));
  92.     Y:=round(rad*sin (deg));
  93.     putpixel (x+160,y+100,col);
  94.     deg:=deg+0.005;
  95.   until (deg>6.4);
  96. END;
  97.  
  98.  
  99. {──────────────────────────────────────────────────────────────────────────}
  100. Procedure Line2 (x1,y1,x2,y2:integer;col:byte);
  101.   { This draws a line from x1,y1 to x2,y2 using the first method }
  102. VAR x,y,xlength,ylength,dx,dy:integer;
  103.     xslope,yslope:real;
  104. BEGIN
  105.   xlength:=abs (x1-x2);
  106.   if (x1-x2)<0 then dx:=-1;
  107.   if (x1-x2)=0 then dx:=0;
  108.   if (x1-x2)>0 then dx:=+1;
  109.   ylength:=abs (y1-y2);
  110.   if (y1-y2)<0 then dy:=-1;
  111.   if (y1-y2)=0 then dy:=0;
  112.   if (y1-y2)>0 then dy:=+1;
  113.   if (dy=0) then BEGIN
  114.     if dx<0 then for x:=x1 to x2 do
  115.       putpixel (x,y1,col);
  116.     if dx>0 then for x:=x2 to x1 do
  117.       putpixel (x,y1,col);
  118.     exit;
  119.   END;
  120.   if (dx=0) then BEGIN
  121.     if dy<0 then for y:=y1 to y2 do
  122.       putpixel (x1,y,col);
  123.     if dy>0 then for y:=y2 to y1 do
  124.       putpixel (x1,y,col);
  125.     exit;
  126.   END;
  127.   xslope:=xlength/ylength;
  128.   yslope:=ylength/xlength;
  129.   if (yslope/xslope<1) and (yslope/xslope>-1) then BEGIN
  130.     if dx<0 then for x:=x1 to x2 do BEGIN
  131.                    y:= round (yslope*x);
  132.                    putpixel (x,y,col);
  133.                  END;
  134.     if dx>0 then for x:=x2 to x1 do BEGIN
  135.                    y:= round (yslope*x);
  136.                    putpixel (x,y,col);
  137.                  END;
  138.   END
  139.   ELSE
  140.   BEGIN
  141.     if dy<0 then for y:=y1 to y2 do BEGIN
  142.                    x:= round (xslope*y);
  143.                    putpixel (x,y,col);
  144.                  END;
  145.     if dy>0 then for y:=y2 to y1 do BEGIN
  146.                    x:= round (xslope*y);
  147.                    putpixel (x,y,col);
  148.                  END;
  149.   END;
  150. END;
  151.  
  152.  
  153. {──────────────────────────────────────────────────────────────────────────}
  154. procedure line(a,b,c,d,col:integer);
  155.   { This draws a line from x1,y1 to x2,y2 using the first method }
  156.  
  157.     function sgn(a:real):integer;
  158.     begin
  159.          if a>0 then sgn:=+1;
  160.          if a<0 then sgn:=-1;
  161.          if a=0 then sgn:=0;
  162.     end;
  163.  
  164. var u,s,v,d1x,d1y,d2x,d2y,m,n:real;
  165.     i:integer;
  166. begin
  167.      u:= c - a;
  168.      v:= d - b;
  169.      d1x:= SGN(u);
  170.      d1y:= SGN(v);
  171.      d2x:= SGN(u);
  172.      d2y:= 0;
  173.      m:= ABS(u);
  174.      n := ABS(v);
  175.      IF NOT (M>N) then
  176.      BEGIN
  177.           d2x := 0 ;
  178.           d2y := SGN(v);
  179.           m := ABS(v);
  180.           n := ABS(u);
  181.      END;
  182.      s := INT(m / 2);
  183.      FOR i := 0 TO round(m) DO
  184.      BEGIN
  185.           putpixel(a,b,col);
  186.           s := s + n;
  187.           IF not (s<m) THEN
  188.           BEGIN
  189.                s := s - m;
  190.                a:= a +round(d1x);
  191.                b := b + round(d1y);
  192.           END
  193.           ELSE
  194.           BEGIN
  195.                a := a + round(d2x);
  196.                b := b + round(d2y);
  197.           END;
  198.      end;
  199. END;
  200.  
  201.  
  202. {──────────────────────────────────────────────────────────────────────────}
  203. Procedure PalPlay;
  204.   { This procedure mucks about with our "virtual pallette", then shoves it
  205.     to screen. }
  206. Var Tmp : Array[1..3] of Byte;
  207.   { This is used as a "temporary color" in our pallette }
  208.     loop1 : Integer;
  209. BEGIN
  210.    Move(Pall[199],Tmp,3);
  211.      { This copies color 199 from our virtual pallette to the Tmp variable }
  212.    Move(Pall[1],Pall[2],198*3);
  213.      { This moves the entire virtual pallette up one color }
  214.    Move(Tmp,Pall[1],3);
  215.      { This copies the Tmp variable to the bottom of the virtual pallette }
  216.    WaitRetrace;
  217.    For loop1:=1 to 199 do
  218.      pal (loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
  219. END;
  220.  
  221.  
  222. BEGIN
  223.   ClrScr;
  224.   Writeln ('This sample program will test out our line and circle algorithms.');
  225.   Writeln ('In the first part, many circles will be draw creating (hopefully)');
  226.   Writeln ('a "tunnel" effect. I will the rotate the pallete to make it look');
  227.   Writeln ('nice. I will then draw some lines and rotate the pallette on them');
  228.   Writeln ('too. Note : I am using the slower (first) line algorithm (in');
  229.   Writeln ('procedure line2). Change it to Procedure Line and it will be using');
  230.   Writeln ('the second line routine. NB : For descriptions on how pallette works');
  231.   Writeln ('have a look at part two of this series; I won''t re-explain it here.');
  232.   Writeln;
  233.   Writeln ('Remember to send me any work you have done, I am most eager to help.');
  234.   Writeln; Writeln;
  235.   Writeln ('Hit any key to continue ...');
  236.   Readkey;
  237.   setmcga;
  238.  
  239.   For Loop1 := 1 to 199 do BEGIN
  240.     Pall[Loop1,1] := Loop1 mod 30+33;
  241.     Pall[Loop1,2] := 0;
  242.     Pall[Loop1,3] := 0;
  243.   END;
  244.        { This sets colors 1 to 199 to values between 33 to 63. The MOD
  245.          function gives you the remainder of a division, ie. 105 mod 10 = 5 }
  246.  
  247.    WaitRetrace;
  248.    For loop1:=1 to 199 do
  249.      pal (loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
  250.         { This sets the true pallette to variable Pall }
  251.  
  252.   for loop1:=1 to 90 do
  253.     circle (160,100,loop1,loop1);
  254.        { This draws 90 circles all with centres at 160,100; with increasing
  255.          radii and colors. }
  256.  
  257.   Repeat
  258.     PalPlay;
  259.   Until keypressed;
  260.   Readkey;
  261.  
  262.   for loop1:=1 to 199 do
  263.     line2 (0,1,319,loop1,loop1);   { *** Replace Line2 with Line to use the
  264.                                          second line algorithm *** }
  265.        { This draws 199 lines, all starting at 0,1 }
  266.  
  267.   Repeat
  268.     PalPlay;
  269.   Until keypressed;
  270.  
  271.   readkey;
  272.   SetText;
  273.   Writeln ('All done. Okay, so maybe it wasn''t a tunnel effect, but you get the');
  274.   Writeln ('general idea ;-) This concludes the third sample program in the ASPHYXIA');
  275.   Writeln ('Training series. You may reach DENTHOR under the name of GRANT SMITH');
  276.   Writeln ('on the MailBox BBS, or leave a message to ASPHYXIA on the ASPHYXIA BBS.');
  277.   Writeln ('Get the numbers from Roblist, or write to :');
  278.   Writeln ('             Grant Smith');
  279.   Writeln ('             P.O. Box 270');
  280.   Writeln ('             Kloof');
  281.   Writeln ('             3640');
  282.   Writeln ('I hope to hear from you soon!');
  283.   Writeln; Writeln;
  284.   Write   ('Hit any key to exit ...');
  285.   Readkey;
  286. END.
  287.